\ SwiftHarness.fth - FCOM portability harness for SwiftForth
\ Tom Dixon
\ 9/15/2008


\ **** Error Handling ****

THROW#
   s" Dispatch Interface not returned"  >THROW ENUM err_NotDispatch  
   s" Invalid Bind Type"                >THROW ENUM err_InvBind      
   s" Unable to Bind to type"           >THROW ENUM err_Bind         
   s" Unable to get type info"          >THROW ENUM err_GetTypeInfo  
   s" Unable to get Documentation"      >THROW ENUM err_GetDoc       
   s" Error Loading Type Library"       >THROW ENUM err_LoadTypeLib  
   s" Error Getting TypeComp"           >THROW ENUM err_GetTypeComp  
   s" No Virtual Interface"             >THROW ENUM err_NoVI         
   s" Not An Interface"                 >THROW ENUM err_NotIF        
   s" Variant Stack Full"               >THROW ENUM err_VarStFull    
   s" Unable to Call Dispatch"          >THROW ENUM err_CantDispatch 
   s" Unable to Find ProgID"            >THROW ENUM err_NoProgID     
   s" Unable to Get IUnknown"           >THROW ENUM err_NoIUnknown   
   s" Not a valid COM Structure"        >THROW ENUM err_NoValStruct  

   s" Unable to Allocate String"        >THROW ENUM err_BadAlloc     

   s" Invalid Guid Length"              >THROW ENUM err_GUIDlen      
   s" Not a CLSID"                      >THROW ENUM err_BadCLSID     

   s" Unable to get IUnknown interface" >THROW ENUM err_IUnknown     
   s" Unable to create ActiveX Control" >THROW ENUM err_AXcreate     
   s" Unable to get Interface"          >THROW ENUM err_noIF         
TO THROW#


\ **** Missing Synonym ****
[defined] synonym 0= [if]
  : SYNONYM 
     : 
     BL WORD FIND 1 = IF IMMEDIATE THEN COMPILE, 
     POSTPONE ; ; 
[then]


\ **** Windows API Access ****

library oleaut32.dll
library ole32.dll
library atl.dll


\ **** GUID calls ****

2 IMPORT: StringFromCLSID

: fStringFromCLSID ( ppsz rclsid -- res ) 
   swap StringFromCLSID ;


\ **** UNICODE Calls ****

6 IMPORT: MultiByteToWideChar
8 IMPORT: WideCharToMultiByte
2 IMPORT: SysAllocStringLen
1 IMPORT: SysFreeString 

: fMultiByteToWideChar ( wclen *wc mblen *mb flags cp -- int )
   LOCALS| l1 l2 l3 l4 l5 l6 |
   l1 l2 l3 l4 l5 l6 MultiByteToWideChar ;
   
: fWideCharToMultiByte ( *used *def mblen *mb wclen *wc flags cp -- len )
   LOCALS| l1 l2 l3 l4 l5 l6 l7 l8 |
   l1 l2 l3 l4 l5 l6 l7 l8 WideCharToMultiByte ;
 
: fSysAllocStringLen ( cch pch -- addr ) 
   swap SysAllocStringLen ;
   
: fSysFreeString ( bstr -- ) 
   SysFreeString drop ;

SYNONYM MB>WC fMultiByteToWideChar
SYNONYM WC>MB fWideCharToMultiByte
   
   
\ **** FCOM calls ****

5 IMPORT: CoCreateInstance
2 IMPORT: CLSIDFromProgID
5 IMPORT: LoadRegTypeLib
2 IMPORT: LoadTypeLib
as fCoInitialize 1 IMPORT: CoInitialize
   
: fCoCreateInstance ( ppv riid context pUnkOuter rclsid -- res )
   LOCALS| l1 l2 l3 l4 l5 |
   l1 l2 l3 l4 l5 CoCreateInstance ;
   
: fCLSIDFromProgID ( pclsid pprogid -- res )
   swap CLSIDFromProgID ;
   
: fLoadRegTypeLib ( pptlib lcid wverminor wvermajor rguid -- res )
   LOCALS| l1 l2 l3 l4 l5 |
   l1 l2 l3 l4 l5 LoadRegTypeLib ;
   
: fLoadTypeLib ( pptlib szFile -- res ) 
   swap LoadTypeLib ;

: fCoTaskMemFree ( *pv -- ) 
   CoTaskMemFree ;
   
   
\ **** ActiveX calls ****

4 IMPORT: AtlAxCreateControl
2 IMPORT: AtlAxGetControl

: fAtlAxCreateControl ( ppUnk pstream hWnd lpszName -- res )
   LOCALS| l1 l2 l3 l4 |
   l1 l2 l3 l4 AtlAxCreateControl ;
   
: fAtlAxGetControl ( pptlib szFile -- res )
   swap AtlAxGetControl ;


\ **** SwiftForth Specific Behavior ****

CODE FCOM-CALL ( x1 x2 .. xn a -- x ) 
   EDI PUSH                     \ save important regsiters
   ESI PUSH                     \
   EBP ESP XCHG                 \ swap the stack pointers
   EBX CALL                     \ make the call itself
   EAX EBX MOV                  \ store the result in TOS
   EBP ESP XCHG                 \ restore stacks
   ESI POP                      \ restore registers
   EDI POP
   RET 
END-CODE
   
: INTERFACE-CALL ( n1 n2 n3 ... nx a indx ) \ vtable call
   >r @ dup @ r> cells + @ FCOM-CALL ;

: RUN-INTERFACE ( pointer imethod -- ) \ runtime interface call
   cell+ @ interface-call ;

: COMPILE-INTERFACE ( pointer imethod -- ) \ fast compile interface call
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @
   cell+ @ cells POSTPONE LITERAL 
   POSTPONE + 
   POSTPONE @ 
   POSTPONE FCOM-CALL ;

: RUN-VTABLE ( pointer offset -- ) 
   swap @ dup @ rot + @ FCOM-CALL ;

: COMPILE-VTABLE ( pointer offset -- ) 
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @ 
   POSTPONE LITERAL
   POSTPONE + 
   POSTPONE @ 
   POSTPONE FCOM-CALL ;


\ Getting the address of a local (this is tricky)
LOCAL-VARIABLE REOPEN
  : REFADDR ( -- n ) [+ASM]
     PUSH(EBX)
     'LF [U] EBX MOV
     SPOT @ # EBX ADD
    [-ASM] ;
END-CLASS

LOCAL-VARIABLES REOPEN
  : REF-LOCAL ( -- flag )
      LOCAL? DUP IF SWAP POOL[] REFADDR THEN ;
END-CLASS

: laddr ( <name> -- addr ) \ returns the address of the local variable
   LVAR-COMP REF-LOCAL ?EXIT ; IMMEDIATE


: discard-sinline ( -- ) \ flag to compiler inliner (not needed in w32f)
   ; immediate


\ Global searching - This is system specific.

defer COMsearcher ( str len -- flag )

\ Until it gets re-defined
:noname 2drop false ; is COMsearcher 


: (comfind) ( c-addr len 0 | i*x true -- caddr len 0 | j*x true )
   if true exit then 
   2dup 2>r COMsearcher 2r> rot if
     2drop true 
   else 
     false
   then ;
  
' (comfind) UNDEFINED >CHAIN

: AtCold ( xt -- ) \ adds xt to initialization chain
   'OnLoad >CHAIN ;

: AtExit ( xt -- ) \ adds xt to exit chain
   'OnExit >CHAIN ;

\ **** Other Odds and Ends ****
SYNONYM W, H,

: istr= ( str len str len -- flag ) 
   COMPARE(NC) 0= ;